Option Explicit

' この VBA プログラムは、Excel の .xlsm ファイルにて、
' ボタンから呼び出す形で使用します。
' シート上で、.js に変換したい図形を選択してから
' そのボタンを押すと、
' その図形の名前の .js ファイルが作成されます。
' step3 drawShape.html 内にて、
' <script src="step2 shape0.js"></script>
' のファイル名部分を書き換えれば、JavaScript で
' 描画されるはずです。


' outputShapeToJS() から参照されている
Const shapeTypes_ As String = "dummy msoAutoShape msoCallout msoChart msoComment msoFreeform msoGroup msoEmbeddedOLEObject msoFormControl msoLine msoLinkedOLEObject msoLinkedPicture msoOLEControlObject msoPicture msoPlaceholder msoTextEffect msoMedia msoTextBox msoScriptAnchor msoTable msoCanvas msoDiagram msoInk msoInkComment msoSmartArt msoSlicer"

Const editingTypes_ As String = "msoEditingAuto msoEditingCorner msoEditingSmooth msoEditingSymmetric"

Const segmentTypes_ As String = "msoSegmentLine msoSegmentCurve"


Public OUT As Object


Sub 図形をJSへ出力_Click()
'図をそれぞれ FreeForm に変換する



'check.
If Not VarType(Selection) = vbObject Then
MsgBox "図形が選択されていない"
End
End If


Dim theShape As Shape
Set theShape = Selection.ShapeRange(1) '''

'check. 変換できない図形かどうか事前確認
checkShape theShape

'check. ダブルクオートは削除
theShape.Name = Replace(theShape.Name, """", "")

'check. コロンは全角
theShape.Name = Replace(theShape.Name, ":", "：")

'check.
bugfixShape theShape


'書き込み準備
Set OUT = CreateObject("ADODB.Stream") '''
OUT.Charset = "UTF-8"
OUT.LineSeparator = adLF
OUT.Open

OUTPUT "if( typeof shapez === ""undefined"" ) shapez = new Object();"
OUTPUT "if( typeof shapes === ""undefined"" ) shapes = new Array();"

' Application.ScreenUpdating = False
Dim freeForm As Shape
Set freeForm = convertToFreeform(theShape) ' FreeForm へ変換し、'''
outputShapeToJS freeForm, 0, False ' FreeForm を元に JavaScript を出力

Selection.Delete ' FreeForm を削除
Set freeForm = Nothing

theShape.Select ' 元の図形を選択

OUT.SaveToFile ActiveWorkbook.Path & "\" & theShape.Name & ".js", 2
OUT.Close
Set OUT = Nothing


Debug.Print vbCr & "====="

Set theShape = Nothing

End Sub


'=== 主要

Function convertToFreeform(theShape As Shape, Optional tabs As String = "", Optional history As String = "") As Shape


If theShape.Type = msoGroup Then
'--- グループの場合

Dim originalLeft As Single
Dim originalTop As Single
originalLeft = theShape.Left
originalTop = theShape.Top
Dim maxSize As Single
If theShape.Width > theShape.Height Then
maxSize = theShape.Width
Else
maxSize = theShape.Height
End If
If theShape.Left < maxSize / 2 Then
theShape.Left = maxSize / 2
End If
If theShape.Top < maxSize / 2 Then
theShape.Top = maxSize / 2
End If




Debug.Print tabs & "■Group:" & theShape.Name
' 子をリストアップする
' グループ解除する

' グループが含む子をリストアップする
Dim theShapeIDBak As String: theShapeIDBak = theShape.id
Dim theShapeNameBak As String: theShapeNameBak = theShape.Name

Dim groupItems() As Shape
groupItems = groupToArray(theShape)
' 後に ungroup されることで、child や parentGroup などのプロパティに不都合が起こる。
' かもしれない。


' グループ解除する
theShape.Ungroup

Dim freeForms() As Shape
Dim freeFormsCount: freeFormsCount = 0

Dim i As Integer
For i = LBound(groupItems) To UBound(groupItems)
Dim groupItem As Shape
Set groupItem = groupItems(i) '''

Dim freeForm As Shape

If groupItem.child Then
' ungroup したとき、その子はまだ何か別の図形の子である（孫）
Debug.Print tabs & "child:" & groupItem.Name
If InStr(1, history, "[" & groupItem.ParentGroup.id & "]", 1) = 0 Then
history = history & "[" & groupItem.ParentGroup.id & "]"

Set freeForm = convertToFreeform(groupItem.ParentGroup, tabs & vbTab, history) '''
freeForm.Left = groupItem.ParentGroup.Left
freeForm.Top = groupItem.ParentGroup.Top

ReDim Preserve freeForms(freeFormsCount)
Set freeForms(freeFormsCount) = freeForm '''
freeFormsCount = freeFormsCount + 1

End If
Else
Debug.Print tabs & "not child:" & groupItem.Name
' ungroup したとき、その子は単一図形である
Set freeForm = convertToFreeform(groupItem, tabs & vbTab, history) '''
' freeForm.Left = groupItem.Left
' freeForm.Top = groupItem.Top

ReDim Preserve freeForms(freeFormsCount)
Set freeForms(freeFormsCount) = freeForm '''
freeFormsCount = freeFormsCount + 1
End If

Set freeForm = Nothing
Set groupItem = Nothing
Next i

'再グループ化

selectShapes groupItems
Set theShape = Selection.Group.ShapeRange(1) ' これは解放しなくてよい
theShape.Name = theShapeNameBak
' theShape.Select

'check.　とはいえ新しいグループだから ID は変わる
history = Replace(history, "[" & theShapeIDBak & "]", "[" & theShape.id & "]")

theShape.Left = originalLeft
theShape.Top = originalTop


selectShapes freeForms
Dim newGroup As Shape
Set newGroup = Selection.ShapeRange.Group '''


newGroup.Left = originalLeft + 12
newGroup.Top = originalTop + 12


newGroup.Select
Set convertToFreeform = newGroup


Erase freeForms
Set newGroup = Nothing

Else
'--- 単一図形の場合

Debug.Print tabs & "●Shape:" & theShape.Name



Dim vFlipBak
vFlipBak = theShape.VerticalFlip
If vFlipBak Then
theShape.Flip (msoFlipVertical)
End If

Dim hFlipBak
hFlipBak = theShape.HorizontalFlip
If hFlipBak Then
theShape.Flip (msoFlipHorizontal)
End If

Dim rotationBak
rotationBak = theShape.Rotation
theShape.Rotation = 0


duplicate theShape

Dim tmpShape As Shape
Set tmpShape = Selection.ShapeRange(1) '''


tmpShape.Left = theShape.Left
tmpShape.Top = theShape.Top


Call tmpShape.Nodes.SetPosition(2, 100, 100)

Dim node1X As Single
Dim node1Y As Single

Dim pointsArray As Variant
pointsArray = tmpShape.Nodes(1).Points
node1X = pointsArray(1, 1)
node1Y = pointsArray(1, 2)

Set tmpShape = Nothing

Selection.Delete

duplicate theShape

Dim newShape As Shape
Set newShape = Selection.ShapeRange(1) '''

newShape.Left = theShape.Left
newShape.Top = theShape.Top

Call newShape.Nodes.SetPosition(1, node1X, node1Y)
pointsArray = newShape.Nodes(1).Points
node1X = pointsArray(1, 1)
node1Y = pointsArray(1, 2)

If rotationBak Then
theShape.Rotation = rotationBak
newShape.Rotation = rotationBak
End If
If hFlipBak Then
theShape.Flip (msoFlipHorizontal)
newShape.Flip (msoFlipHorizontal)
End If
If vFlipBak Then
theShape.Flip (msoFlipVertical)
newShape.Flip (msoFlipVertical)
End If


Set convertToFreeform = newShape


Set newShape = Nothing

Application.ScreenUpdating = False
Application.ScreenUpdating = True

End If

End Function

Sub outputShapeToJS(theShape As Variant, tabCount As Integer, isChild As Boolean)

Dim shapeTypes As Variant: shapeTypes = Split(shapeTypes_, " ")
Dim editingTypes As Variant: editingTypes = Split(editingTypes_, " ")
Dim segmentTypes As Variant: segmentTypes = Split(segmentTypes_, " ")

If isChild Then
OUTPUT tabs(tabCount) & """" & theShape.id & """ : {"
Else
OUTPUT tabs(tabCount) & "shapez[ """ & theShape.id & """ ] = {"
End If

tabCount = tabCount + 1

OUTPUT tabs(tabCount) & "name : """ & theShape.Name & ""","
OUTPUT tabs(tabCount) & "type : """ & shapeTypes(theShape.Type) & ""","
OUTPUT tabs(tabCount) & "left : " & theShape.Left & ","
OUTPUT tabs(tabCount) & "top : " & theShape.Top & ","
OUTPUT tabs(tabCount) & "width : " & theShape.Width & ","
OUTPUT tabs(tabCount) & "height : " & theShape.Height & ","
OUTPUT tabs(tabCount) & "rotation : " & theShape.Rotation & ","
OUTPUT tabs(tabCount) & "zOrder : " & theShape.ZOrderPosition & ","

OUTPUT tabs(tabCount) & "fill : {"
OUTPUT tabs(tabCount + 1) & "visible : " & theShape.Fill.Visible & ","
OUTPUT tabs(tabCount + 1) & "foreColor : {"
OUTPUT tabs(tabCount + 2) & "RGB : " & theShape.Fill.ForeColor.RGB & ","
OUTPUT tabs(tabCount + 1) & "},"
OUTPUT tabs(tabCount) & "},"

OUTPUT tabs(tabCount) & "line : {"
OUTPUT tabs(tabCount + 1) & "visible : " & theShape.Line.Visible & ","
OUTPUT tabs(tabCount + 1) & "foreColor : {"
OUTPUT tabs(tabCount + 2) & "RGB : " & theShape.Line.ForeColor.RGB & ","
OUTPUT tabs(tabCount + 1) & "},"
OUTPUT tabs(tabCount + 1) & "weight : " & theShape.Line.Weight & ","
OUTPUT tabs(tabCount) & "},"

If 0 Then
OUTPUT tabs(tabCount) & "drawingObject : {"
OUTPUT tabs(tabCount + 1) & "interior : {"
OUTPUT tabs(tabCount + 2) & "color : " & theShape.DrawingObject.Interior.Color & ","
OUTPUT tabs(tabCount + 1) & "},"
OUTPUT tabs(tabCount) & "},"
End If



If theShape.Type = msoGroup Then

' グループである

OUTPUT tabs(tabCount) & "groupItemz : {"

Dim childShape As Shape
For Each childShape In theShape.groupItems
outputShapeToJS childShape, tabCount + 1, True
Next childShape

OUTPUT tabs(tabCount) & "}, // groupItemz"


ElseIf theShape.Type = msoFreeform Then

' フリーフォームである

Dim arr As Variant
Dim x, y

OUTPUT tabs(tabCount) & "nodes : [ // " & theShape.Nodes.count

tabCount = tabCount + 1

Dim i As Integer
For i = 1 To theShape.Nodes.count
Dim theNode As ShapeNode
Set theNode = theShape.Nodes(i) '''
OUTPUT tabs(tabCount) & "{ // " & (i - 1)

tabCount = tabCount + 1

On Error Resume Next
Dim tmp As Integer
tmp = -1
tmp = theNode.EditingType
On Error GoTo 0
If tmp = -1 Then
OUTPUT tabs(tabCount) & "editingType : null,"
Else
OUTPUT tabs(tabCount) & "editingType : """ & editingTypes(theNode.EditingType) & ""","
End If

OUTPUT tabs(tabCount) & "segmentType : """ & segmentTypes(theNode.SegmentType) & ""","

arr = theNode.Points
x = arr(1, 1)
y = arr(1, 2)

OUTPUT tabs(tabCount) & "points : [ " & x & ", " & y & " ],"

tabCount = tabCount - 1

OUTPUT tabs(tabCount) & "},"

Set theNode = Nothing
Next i

tabCount = tabCount - 1

OUTPUT tabs(tabCount) & "], // nodes"

End If


tabCount = tabCount - 1

If isChild Then
OUTPUT tabs(tabCount) & "}, // groupItems[ """ & theShape.id & """ ]"
Else
OUTPUT tabs(tabCount) & "} // shapez[ """ & theShape.id & """ ]"
OUTPUT tabs(tabCount) & "shapes.push( shapez[ """ & theShape.id & """ ] );"
OUTPUT tabs(tabCount) & "loadedShape = shapez[ """ & theShape.id & """ ];"
End If


End Sub ' outputShapeToJS


'=== 小物

Sub OUTPUT(text As String)
OUT.WriteText text, 1 ' 1 で改行
End Sub

Function tabs(count)
tabs = String(count, vbTab)
End Function


'=== UTLs local

Sub debug_array(ByRef theArray)
Debug.Print "--- debug_array() ---"
Debug.Print LBound(theArray) & "～" & UBound(theArray)
Dim i As Integer
For i = 0 To UBound(theArray)
Debug.Print i, theArray(i).Name
Next i
Debug.Print "---/debug_array() ---"
End Sub

Sub checkShape(theShape)
If theShape.Type = msoGroup Then
Dim childShape As Shape
For Each childShape In theShape.groupItems
If childShape.Nodes.count = 0 Then
childShape.Select
MsgBox "この図形は node がないので変換できません"
End
End If
Next
Else
If theShape.Nodes.count = 0 Then
theShape.Select
MsgBox "この図形は node がないので変換できません"
End
End If
End If
End Sub


'=== UTLs global (special)

Sub duplicate(theShape As Shape)

' ３種類のエラーを検出する。
' paste pasteメソッド実行時のエラーは on error で retry する。
' otori copyメソッドが遅れた場合、pasteされたものは事前データ（おとり）であることを検出し goto で retry する。
' extra コピーした結果の図形の名前がコピー元と異なる場合 goto で retry する。

' 正規表現　雑用
Dim re As Object
Dim theMatches As Variant

' エラー検出用
Dim baseName As String
Set re = CreateObject("VBScript.RegExp") '''
re.Pattern = "(.+) (\d+)$"

Set theMatches = re.Execute(theShape.Name) '''
If theMatches.count > 0 Then
baseName = theMatches(0).subMatches(0)
End If

Set re = Nothing
Set theMatches = Nothing

' デバッグ用
Dim tryCount: tryCount = 0
Dim errorLogs As String: errorLogs = ""
Dim errorLog As String: errorLog = ""

'theShape.BottomRightCell.Select
theShape.TopLeftCell.Select

On Error GoTo LabelRetry ' [paste] paste メソッドでエラーしたら retry する
LabelRetry:

tryCount = tryCount + 1
'check.　デバッグ時の無限ループ防止用
If tryCount > 100 Then
Debug.Print "エラー過多"
Exit Sub
End If

errorLogs = errorLogs & errorLog


' おとり
Dim rect As Shape
Set rect = ActiveSheet.shapes.AddShape(msoShapeRectangle, 100, 100, 100, 100)
rect.Name = "__otori__"
rect.Cut


theShape.Copy


DoEvents
Application.Wait [Now()] + 70 / 86400000

errorLog = "paste, "
ActiveSheet.Paste '★★★

'check.　[otori] おとりを貼り付けした
If Selection.ShapeRange(1).Name = "__otori__" Then
Selection.Delete
errorLog = "otori, "
GoTo LabelRetry
End If

'check.　[extra] 以前コピーされた図形を貼り付けした
If baseName <> "" Then
Set re = CreateObject("VBScript.RegExp") '''
re.Pattern = "^" & baseName & " (\d+)$"
Set theMatches = re.Execute(Selection.ShapeRange(1).Name) '''

Dim theMatchesCount
theMatchesCount = theMatches.count

Set re = Nothing
Set theMatches = Nothing

If theMatchesCount = 0 Then
Selection.Delete
errorLog = "extra, "
GoTo LabelRetry
End If
End If

On Error GoTo 0

'debug.
If tryCount > 1 Then
Debug.Print "◆◆◆duplicate tryCount " & (tryCount - 1) & " (" & errorLogs & ") at " & theShape.Name
End If

'debug.
Selection.ShapeRange(1).Name = Selection.ShapeRange(1).Name

End Sub

Sub bugfixShape(theShape As Shape, Optional ByRef idListStringP As String = "")
If theShape.Type = msoGroup Then
' グループ

' バグを持っているか
Dim hasBug As Boolean
hasBug = False
Dim groupItem As Shape
For Each groupItem In theShape.groupItems
'check グループ内の子なのに child が 0（バグ）
If groupItem.child = 0 Then
hasBug = True
GoTo label_bugfixShapeBreak1
End If
Next groupItem

label_bugfixShapeBreak1:


' バグを持っている場合は、
If hasBug Then

Dim item As Shape ' for用

Dim nameBak As String
nameBak = theShape.Name
Dim idBak As String
idBak = theShape.id

' グループを解除し、
Dim ungroupedShapes As ShapeRange
Set ungroupedShapes = theShape.Ungroup 'ungroup'''

Dim idListStringC As String
For Each item In ungroupedShapes
idListStringC = idListStringC & "," & item.id
Next item
'check.
idListStringC = idListStringC & ","

' 入れ子なら再帰する。
For Each item In ungroupedShapes
If item.Type = msoGroup Then
bugfixShape item, idListStringC
End If
Next item

Set ungroupedShapes = Nothing

' 再グループ化する
Dim ids() As String
ids = Split(idListStringC, ",")
Dim id As Variant
For Each id In ids
If id <> "" Then
For Each item In ActiveSheet.shapes
If item.id = id Then
item.Select False
GoTo label_bugfixShapeBreak2
End If
Next item
End If
label_bugfixShapeBreak2:
Next id

Set theShape = Selection.ShapeRange.Group ' これは解放しなくてよい

'check.
idListStringP = Replace(idListStringP, "," & idBak & ",", "," & theShape.id & ",")

theShape.Name = nameBak

End If

End If

theShape.Select Replace:=False

End Sub


'=== UTLs global

Sub selectShapes(ByRef shapes)
shapes(0).TopLeftCell.Select
Dim i As Integer
For i = LBound(shapes) To UBound(shapes)
If shapes(i).child Then
shapes(i).ParentGroup.Select Replace:=False
Else
shapes(i).Select Replace:=False
End If
Next i
End Sub

Function groupToArray(theShape As Shape) As Shape()
'グループが含む子を単純に（入れ子を考慮せず）配列にする

'check.
If Not theShape.Type = msoGroup Then
MsgBox "groupToArray()、引数はグループではない"
Return
End If

Dim children() As Shape
ReDim children(theShape.groupItems.count - 1)

Dim i As Integer
For i = 0 To theShape.groupItems.count - 1
Set children(i) = theShape.groupItems(i + 1)
Next i

groupToArray = children

End Function